home *** CD-ROM | disk | FTP | other *** search
Text File | 1993-07-17 | 47.9 KB | 1,082 lines |
- ;;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base: 8.; Fonts: cptfont -*-
-
- ;;; (C) Copyright 1985 Massachusetts Institute of Technology
- ;;;
- ;;; Permission to use, copy, modify, distribute, and sell this software
- ;;; and its documentation for any purpose is hereby granted without fee,
- ;;; provided that the above copyright notice appear in all copies and that
- ;;; both that copyright notice and this permission notice appear in
- ;;; supporting documentation, and that the name of M.I.T. not be used in
- ;;; advertising or publicity pertaining to distribution of the software
- ;;; without specific, written prior permission. M.I.T. makes no
- ;;; representations about the suitability of this software for any
- ;;; purpose. It is provided "as is" without express or implied warranty.
- ;;;
-
- ;;;This file contains all of the high level code that the redisplay uses
-
-
- (DEFWHOPPER (SCREEN-BOX :REDISPLAY-PASS-1) (&REST ARGS-TO-METHOD)
- (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
- FORCE-REDISPLAY-INFS?)))
- ;(IF *COMPLETE-REDISPLAY-IN-PROGRESS?* (ERASE-SCREEN-OBJ SELF))
- (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD)))
-
- (DEFWHOPPER (SCREEN-BOX :REDISPLAY-PASS-2) (&REST ARGS-TO-METHOD)
- (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
- FORCE-REDISPLAY-INFS?)))
- (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD)))
-
-
- ;;; Set things up so that the actual redisplay methods will have the
- ;;; coordinate rescaling and clipping automatically taken care of.
-
- ;;; During redisplay-pass-1 the only region of the screen the redisplay
- ;;; methods are allowed to draw in is the region of the screen currently
- ;;; occupied by the screen obj.
- (DEFWHOPPER (SCREEN-OBJ :REDISPLAY-PASS-1) (&REST ARGS-TO-METHOD)
- (WITH-DRAWING-INSIDE-REGION (X-OFFSET Y-OFFSET WID HEI)
- (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD)))
-
- ;;; During redisplay-pass-2 the only part of the screen the redisplay
- ;;; methods are allowed to draw in is the max of the region currently
- ;;; occupied by the screen obj, and the space that will be occupied by
- ;;; the screen obj when redisplay-pass-2 is complete.
- (DEFWHOPPER (SCREEN-OBJ :REDISPLAY-PASS-2) (&REST ARGS-TO-METHOD)
- (WITH-DRAWING-INSIDE-REGION (X-OFFSET Y-OFFSET (MAX WID NEW-WID) (MAX HEI NEW-HEI))
- (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD)))
-
- ;;; SCREEN-BOXES also have methods called redisplay-screen-rows-pass-1,
- ;;; and redisplay-screen-rows-pass-2. The clipping and rescaling for
- ;;; these methods is similar to the clipping and rescaling for the other
- ;;; redisplay-pass-1 and redisplay-pass-2 methods, except that here the
- ;;; region of the screen of that is being draw inside is a subpart of
- ;;; the screen obj, the screen-box's screen-rows.
- (DEFWHOPPER (SCREEN-BOX :REDISPLAY-INFERIORS-PASS-1) (INFS-NEW-MAX-WID INFS-NEW-MAX-HEI
- &REST ARGS-TO-METHOD)
- (PORT-REDISPLAYING-HISTORY (ACTUAL-OBJ)
- (MULTIPLE-VALUE-BIND (IL IT IR IB)
- (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
- (WITH-CLIPPING-INSIDE (IL IT (- WID IL IR) (- HEI IT IB))
- (LEXPR-CONTINUE-WHOPPER INFS-NEW-MAX-WID INFS-NEW-MAX-HEI ARGS-TO-METHOD)))))
-
- (DEFWHOPPER (SCREEN-BOX :REDISPLAY-INFERIORS-PASS-2) (&REST ARGS-TO-METHOD)
- (MULTIPLE-VALUE-BIND (IL IT IR IB)
- (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
- (WITH-CLIPPING-INSIDE (IL IT (- (MAX WID NEW-WID) IL IR) (- (MAX HEI NEW-HEI) IT IB))
- (LEXPR-CONTINUE-WHOPPER ARGS-TO-METHOD))))
-
-
-
- ;;; Deciding about whether or not a screen-obj needs redisplay. Because
- ;;; of speed consideration this is split into two different methods:
- ;;; :NEEDS-REDISPLAY-PASS-1? and NEEDS-REDISPLAY-PASS-2?. Actually, only
- ;;; :needs-redisplay-pass-1? does any work at all, it basically decides
- ;;; if the screen-obj needs redisplay, and if it does it sets a flag and
- ;;; returns true. Later when :needs-redisplay-pass-2? is called, all it
- ;;; has to do is check the flag. (Even later, the flag will get cleared
- ;;; by the :got-redisplayed? method).
- ;;;
- ;;; :NEEDS-REDISPLAY-PASS-1 will return true in any of the following cases:
- ;;;
- ;;; The value of the variable *complete-redisplay-in-progress?* is non-nil.
- ;;;
- ;;; The actual obj has changed since the last time the screen
- ;;; obj got redisplayed.
- ;;;
- ;;; The amount of space the screen obj is going to have to fit
- ;;; into is smaller than the space it is currently occupying.
- ;;;
- ;;; The screen obj was clipped last time it got displayed, and
- ;;; now it has more space to fit into.
- ;;;
- ;;; ** NOTE!!! This is another one of those functions that you weird **
- ;;; ** speed freaks will say, "But this could be much faster!". Well **
- ;;; ** sure, but remember people have to be able to read this shit **
- ;;; ** and figure out what is going on. Also keep in mind that the **
- ;;; ** compiler optmizes boolean expressions etc. **
- (DEFMETHOD (SCREEN-OBJ :NEEDS-REDISPLAY-PASS-1?) (&OPTIONAL (MAX-WID NIL) (MAX-HEI NIL))
- (COND ((OR (NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)
- (NOT-NULL NEEDS-REDISPLAY-PASS-2?)
- (NOT-NULL FORCE-REDISPLAY-INFS?)
- (< TICK (TELL ACTUAL-OBJ :TICK))
- (AND (NOT-NULL MAX-WID) (< MAX-WID WID))
- (AND (NOT-NULL MAX-HEI) (< MAX-HEI HEI))
- (AND (NOT-NULL X-GOT-CLIPPED?) (NOT-NULL MAX-WID) (> MAX-WID WID))
- (AND (NOT-NULL Y-GOT-CLIPPED?) (NOT-NULL MAX-HEI) (> MAX-HEI HEI)))
- (SETQ NEEDS-REDISPLAY-PASS-2? T))
- (T NIL)))
-
- (DEFMETHOD (SCREEN-OBJ :NEEDS-REDISPLAY-PASS-2?) ()
- (OR (NOT-NULL NEEDS-REDISPLAY-PASS-2?)
- (NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)))
-
- (DEFMETHOD (SCREEN-OBJ :SET-FORCE-REDISPLAY-INFS?) (&REST IGNORE)
- (SETQ FORCE-REDISPLAY-INFS? T)
- (TELL SELF :SET-NEEDS-REDISPLAY-PASS-2? T))
-
- (DEFMETHOD (SCREEN-OBJ :SET-NEEDS-REDISPLAY-PASS-2?) (NEW-VALUE)
- (SETQ NEEDS-REDISPLAY-PASS-2? NEW-VALUE)
- (WHEN (NOT-NULL NEW-VALUE)
- (LET ((SUPERIOR (TELL SELF :SUPERIOR)))
- (WHEN (SCREEN-OBJ? SUPERIOR)
- (TELL SUPERIOR :SET-NEEDS-REDISPLAY-PASS-2? T)))))
-
- (DEFMETHOD (SCREEN-ROW :GOT-REDISPLAYED) ()
- (SETQ WID NEW-WID
- HEI NEW-HEI
- X-GOT-CLIPPED? NEW-X-GOT-CLIPPED?
- Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?
- TICK (TICK)
- NEEDS-REDISPLAY-PASS-2? NIL
- FORCE-REDISPLAY-INFS? NIL
- OUT-OF-SYNCH-MARK NIL))
-
- (DEFMETHOD (SCREEN-BOX :GOT-REDISPLAYED) ()
- (SETQ WID NEW-WID
- HEI NEW-HEI
- X-GOT-CLIPPED? NEW-X-GOT-CLIPPED?
- Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?
- INF-HOR-SHIFT 0
- TICK (TICK)
- NEEDS-REDISPLAY-PASS-2? NIL
- FORCE-REDISPLAY-INFS? NIL))
-
- (DEFMETHOD (ACTUAL-OBJ-MIXIN :TICK) ()
- TICK)
-
- (DEFMETHOD (ACTUAL-OBJ-MIXIN :AFTER :MODIFIED) (&REST IGNORE)
- (SETQ TICK (TICK)))
-
-
-
- ;;; The real job of these methods is to rebuild the screen structure after
- ;;; some change to the actual structure. Before this method runs, the
- ;;; screen structure and the actual structure may or may not be in synch,
- ;;; but after this method runs the screen and actual structures will be
- ;;; in synch. So this method converts old outdated screen structure into
- ;;; new up-to-date screen structure.
- ;;; The way these methods do their work is to loop through the screen and
- ;;; actual structures in parallel, checking as it goes to make sure that
- ;;; the screen structure matches the actual structure. Whenever the two
- ;;; don't match, the screen structure is patched to make them match. At
- ;;; the end of each pass through the loop inf-screen-obj is sure to be
- ;;; in synch with inf-actual-obj. At this point inf-screen-obj is given
- ;;; a chance to do its own :redisplay-pass-1 (recurse), and then it is
- ;;; allowed to make its contribution to the new-wid, new-hei etc. of all
- ;;; the superior's inferior screen objs together.
-
- (DEFMETHOD (SCREEN-BOX :REDISPLAY-INFERIORS-PASS-1)(INFS-NEW-MAX-WID INFS-NEW-MAX-HEI
- &OPTIONAL
- (FIRST-INF-X-OFFSET 0)
- (FIRST-INF-Y-OFFSET 0)
- (SCROLL-TO-INF NIL))
- ;; First we check for port circularity
- (IF (AND (PORT-BOX? ACTUAL-OBJ) (PORT-HAS-BEEN-DISPLAYED-ENOUGH? ACTUAL-OBJ))
- ;; The Actual Box is part of a circular structure AND we have already displayed the
- ;; port the required number of times, so we
- (PROGN
- ;; erase and remove whatever is in the box, then
- (WHEN (AND (NOT-NULL SCREEN-ROWS) (NOT (BOX-ELLIPSIS-STYLE? SCREEN-ROWS)))
- (LET ((SRS SCREEN-ROWS))
- (TELL SELF :KILL-SCREEN-ROW (CAR SCREEN-ROWS))
- (ERASE-SCREEN-OBJS SRS)
- (QUEUE-SCREEN-OBJS-FOR-DEALLOCATION SRS)))
- ;; If there was an ellipsis marker already there, then we need to erase it in
- ;; order to leave a blank space for the marker to be drawn during pass-2
- (WHEN (BOX-ELLIPSIS-STYLE? SCREEN-ROWS)
- (MULTIPLE-VALUE-BIND (IL IT)
- (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
- (FUNCALL (GET SCREEN-ROWS 'ERASE-SELF) IL IT)))
- ;; put a Box ellipsis marker into the inferiors slot of the screen box
- (SETQ SCREEN-ROWS *BOX-ELLIPSIS-CURRENT-STYLE*)
- ;; then return the necessary values
- (MULTIPLE-VALUE-BIND (EWID EHEI)
- (FUNCALL (GET *BOX-ELLIPSIS-CURRENT-STYLE* 'SIZE))
- (VALUES (MIN EWID INFS-NEW-MAX-WID) (MIN EHEI INFS-NEW-MAX-HEI)
- (> EWID INFS-NEW-MAX-WID) (> EHEI INFS-NEW-MAX-HEI))))
-
-
- ;; If the port has an ellipsis marker when it shouldn't, then erase and remove it
- (WHEN (AND (PORT-BOX? ACTUAL-OBJ) (BOX-ELLIPSIS-STYLE? SCREEN-ROWS))
- (MULTIPLE-VALUE-BIND (IL IT)
- (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
- (FUNCALL (GET SCREEN-ROWS 'ERASE-SELF) IL IT))
- (SETQ SCREEN-ROWS NIL))
-
- ;; Bind some useful vars for the main loop to side effect
- (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
- FORCE-REDISPLAY-INFS?))
- (INFS-NEW-WID 0)
- (INFS-NEW-HEI 0)
- (INFS-NEW-X-GOT-CLIPPED? NIL)
- (INFS-NEW-Y-GOT-CLIPPED? NIL)
- (INF-X-OFFSET FIRST-INF-X-OFFSET)
- (INF-Y-OFFSET FIRST-INF-Y-OFFSET))
- ;; At the start of each pass through the loop bind inf-screen-obj,
- ;; and inf-actual-obj to the next obj in the screen and actual
- ;; structures respectively.
- (DO ((INF-ACTUAL-OBJ (OR SCROLL-TO-INF
- (TELL ACTUAL-OBJ :FIRST-INFERIOR-OBJ))
- (TELL INF-ACTUAL-OBJ :NEXT-OBJ))
- (INF-SCREEN-OBJ (TELL SELF :FIRST-SCREEN-OBJ)
- (TELL INF-SCREEN-OBJ :NEXT-SCREEN-OBJ)))
- ;; If there are no more inferior screen-objs or if the current state of
- ;; the clipping means that there is no room to display any more inferiors or the
- ;; box is shrunken
- ;; we quit. If there are any inferior screen-objs left in the old screen
- ;; structure punt them.
- ((OR (NULL INF-ACTUAL-OBJ)
- (TELL SELF :RDP1-OUT-OF-ROOM-TO-DISPLAY-INFERIORS? INFS-NEW-Y-GOT-CLIPPED?)
- (EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK))
- (WHEN (NOT-NULL INF-SCREEN-OBJ)
- (TELL SELF :RDP1-PUNT-EXTRA-SCREEN-OBJS INF-SCREEN-OBJ))
- (VALUES INFS-NEW-WID INFS-NEW-HEI
- INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?))
- ;; If for any reason inf-screen-obj doesn't match inf-actual-obj
- ;; we need to patch up the screen structure. This can be fairly
- ;; hairy, so we call in somebody else to do the job.
- (WHEN (OR (NULL INF-SCREEN-OBJ)
- (NEQ (SCREEN-OBJ-ACTUAL-OBJ INF-SCREEN-OBJ) INF-ACTUAL-OBJ))
- (SETQ INF-SCREEN-OBJ (TELL SELF :RDP1-PATCH-OUT-OF-SYNCH-LOSSAGE
- INF-ACTUAL-OBJ INF-SCREEN-OBJ
- INF-X-OFFSET INF-Y-OFFSET)))
-
- ;; At this point we know that inf-screen-obj and inf-actual-obj
- ;; match. If it wants to let inf-screen-obj do :redisplay-pass-1.
- (WHEN (TELL INF-SCREEN-OBJ :NEEDS-REDISPLAY-PASS-1? INFS-NEW-MAX-WID
- INFS-NEW-MAX-HEI)
- (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-1 INFS-NEW-MAX-WID
- INFS-NEW-MAX-HEI))
- ;; Finally, let inf-screen-obj make its contibution to the total
- ;; new-wid, new-hei etc. of all the inf-screen-objs.
- (MULTIPLE-VALUE (INFS-NEW-WID INFS-NEW-HEI
- INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?
- INF-Y-OFFSET
- INFS-NEW-MAX-HEI)
- ;; inf-screen-obj has to be a screen-row so we don't
- ;; pass INF-X-OFFSET and NEW-MAX-WID
- (TELL INF-SCREEN-OBJ :RDP1-INCREMENT-SUPERIOR-PARAMETERS
- INFS-NEW-WID
- INFS-NEW-HEI
- INFS-NEW-X-GOT-CLIPPED?
- INFS-NEW-Y-GOT-CLIPPED?
- INF-Y-OFFSET
- INFS-NEW-MAX-HEI))))))
-
- (DEFMETHOD (SCREEN-BOX :RDP1-OUT-OF-ROOM-TO-DISPLAY-INFERIORS?) (INFS-NEW-Y-GOT-CLIPPED?)
- INFS-NEW-Y-GOT-CLIPPED?)
-
- (DEFMETHOD (SCREEN-OBJ :RDP1-PUNT-EXTRA-SCREEN-OBJS) (FIRST-SCREEN-OBJ-TO-PUNT)
- (LET ((SCREEN-OBJS-TO-PUNT (TELL FIRST-SCREEN-OBJ-TO-PUNT :SELF-AND-NEXT-SCREEN-OBJS)))
- (ERASE-SCREEN-OBJS SCREEN-OBJS-TO-PUNT)
- (QUEUE-SCREEN-OBJS-FOR-DEALLOCATION SCREEN-OBJS-TO-PUNT)
- (TELL SELF :KILL-SCREEN-OBJ FIRST-SCREEN-OBJ-TO-PUNT)))
-
-
- ;;;this is one of the main screen structure patching routine...
- ;;;it examines the state of the screen box so far and, from the
- ;;;information given, decides which of several, more specific, screen
- ;;;structure patching routines to call
-
- (DEFMETHOD (SCREEN-OBJ :RDP1-PATCH-OUT-OF-SYNCH-LOSSAGE)
- (INF-ACTUAL-OBJ INF-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)
- (LET* ((MATCHING-SCREEN-OBJ
- (TELL INF-ACTUAL-OBJ :ALLOCATE-SCREEN-OBJ-FOR-USE-IN
- (TELL SELF :LOWEST-SCREEN-BOX)))
- (MATCHING-SCREEN-OBJ-SUPERIOR
- (TELL MATCHING-SCREEN-OBJ :SUPERIOR)))
- (COND ((EQ MATCHING-SCREEN-OBJ-SUPERIOR SELF)
- ;; The screen-obj which matches inf-actual-obj must be
- ;; farther along in this screen obj somewhere.
- ;; (One common cause for this is a rubout).
- (TELL SELF :RDP1-PATCH-RUBOUT-INF-STYLE-LOSSAGE-INTERNAL
- MATCHING-SCREEN-OBJ INF-SCREEN-OBJ))
- ((NOT-NULL MATCHING-SCREEN-OBJ-SUPERIOR)
- ;; The screen-obj which matches inf-actual-obj is not in
- ;; in us anywhere, but it is in use somewhere. (Note that
- ;; its superior must come after us, and at the same level).
- (TELL SELF :RDP1-PATCH-RANDOM-STYLE-LOSSAGE-INTERNAL
- MATCHING-SCREEN-OBJ INF-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET))
- (T
- ;; The screen-obj which matches inf-actual-obj is not in
- ;; use anywhere. This means inf-actual-obj is a new actual-
- ;; obj. (Probably the most common cause for this is an
- ;; append cha).
- (TELL SELF :RDP1-PATCH-NEW-INF-STYLE-LOSSAGE-INTERNAL
- MATCHING-SCREEN-OBJ INF-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)))))
-
- (DEFMETHOD (SCREEN-OBJ :RDP1-PATCH-RUBOUT-INF-STYLE-LOSSAGE-INTERNAL)(MATCHING-SCREEN-OBJ
- INF-SCREEN-OBJ)
- ;; Delete and erase the screen objs between inf-screen-obj and matching-
- ;; matching screen-obj, then blt the matching-screen-obj-and-next-screen-objs
- ;; over.
- (LET ((INF-SCREEN-OBJ-AND-NEXT-SCREEN-OBJS
- (TELL INF-SCREEN-OBJ :SELF-AND-NEXT-SCREEN-OBJS)))
- (TELL SELF :DELETE-BETWEEN-SCREEN-OBJS INF-SCREEN-OBJ MATCHING-SCREEN-OBJ)
- ;; **WATCH OUT** At this point we have side-effected the value of
- ;; inf-screen-obj-and-next-screen-objs!!! Its value is now just
- ;; those screen-objs that got deleted. By coincidence, these are the
- ;; screen-objs that need to be erased, and the world is good place.
- ;; Hope that nobody changes :delete-between-screen-objs.
- (MULTIPLE-VALUE-BIND (ERASED-WID ERASED-HEI)
- (SCREEN-OBJS-NEXT-SCREEN-OBJ-DELTA-OFFSETS-WHEN-ERASED
- INF-SCREEN-OBJ-AND-NEXT-SCREEN-OBJS)
- (ERASE-SCREEN-OBJS INF-SCREEN-OBJ-AND-NEXT-SCREEN-OBJS)
- (QUEUE-SCREEN-OBJS-FOR-DEALLOCATION INF-SCREEN-OBJ-AND-NEXT-SCREEN-OBJS)
- (MOVE-SCREEN-OBJS (TELL MATCHING-SCREEN-OBJ :SELF-AND-NEXT-SCREEN-OBJS)
- (- ERASED-WID)
- (- ERASED-HEI))
- MATCHING-SCREEN-OBJ)))
-
-
- (DEFMETHOD (SCREEN-OBJ :RDP1-PATCH-NEW-INF-STYLE-LOSSAGE-INTERNAL)
- (MATCHING-SCREEN-OBJ INF-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)
- ;;Just insert the matching-screen-obj in the right place and we're done.
- (TELL SELF :INSERT-SCREEN-OBJ MATCHING-SCREEN-OBJ INF-SCREEN-OBJ)
- (SET-SCREEN-OBJ-OFFSETS MATCHING-SCREEN-OBJ SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)
- MATCHING-SCREEN-OBJ)
-
- (DEFMETHOD (SCREEN-ROW :RDP1-INCREMENT-SUPERIOR-PARAMETERS) (INFS-NEW-WID
- INFS-NEW-HEI
- INFS-NEW-X-GOT-CLIPPED?
- INFS-NEW-Y-GOT-CLIPPED?
- INF-Y-OFFSET
- INFS-NEW-MAX-HEI)
- (VALUES (MAX INFS-NEW-WID NEW-WID)
- (+ INFS-NEW-HEI NEW-HEI)
- (OR INFS-NEW-X-GOT-CLIPPED? NEW-X-GOT-CLIPPED?)
- (OR INFS-NEW-Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?)
- (+ INF-Y-OFFSET HEI)
- (- INFS-NEW-MAX-HEI NEW-HEI)))
-
-
- ;;;Methods used for redisplaying ROWS
- ;;;
- ;;;The main difference between redisplaying rows and redisplaying boxes is that rows
- ;;;have to know what is going on with their inferiors because chas cannot take care of
- ;;;such things as clipping and drawing by themselves (like rows can)
- ;;;
- ;;;what a row tries to do on REDISPLAY PASS 1 is: it patches up screen structure to be
- ;;;in synch with actual structure, marks the point in the row where the initial out
- ;;;of synch lossage occured, erases ALL chas past this point and tries REAL HARD to
- ;;;preserve the boxes which have already been drawn so they can be bitblted to the right
- ;;;place during pass 2. Drawn boxes which are no longer needed (ones which have been rubbed
- ;;;out) are also erased during pass 1.
- ;;;
- ;;;during REDISPLAY PASS 2, the row then draws in all the characters it has to,
- ;;;starting from the point of out of synch lossage since all chas past this point
- ;;;will have been erased. It also bitblts any existing boxes to the right place
- ;;;and draws any new boxes that were created
-
- (DEFMETHOD (SCREEN-ROW :REDISPLAY-INFERIORS-PASS-1)(INFS-NEW-MAX-WID INFS-NEW-MAX-HEI
- &OPTIONAL
- (FIRST-INF-X-OFFSET 0)
- (FIRST-INF-Y-OFFSET 0))
- (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?*
- (OR *COMPLETE-REDISPLAY-IN-PROGRESS?* FORCE-REDISPLAY-INFS?))
- (INFS-NEW-WID 0) (INFS-NEW-HEI 0)
- (INFS-NEW-X-GOT-CLIPPED? NIL) (INFS-NEW-Y-GOT-CLIPPED? NIL)
- (INF-X-OFFSET FIRST-INF-X-OFFSET)(INF-Y-OFFSET FIRST-INF-Y-OFFSET)
- ;; intialize the BOXES-TO-DISPLAY variable to all the boxes in the actual row
- ;; as each box is displayed, remove it from the list.
- (BOXES-TO-DISPLAY (TELL ACTUAL-OBJ :BOXES-IN-ROW))
- ;; initialize the out of synch flag. this flag is tripped whenever the row gets
- ;; out of synch for the first time
- (OUT-OF-SYNCH-ALREADY NIL))
- ;; if the row was vertically clipped, we want to redraw the entire row
- (WHEN Y-GOT-CLIPPED?
- (SETQ OUT-OF-SYNCH-MARK 0
- OUT-OF-SYNCH-ALREADY T)
- (ERASE-CHAS-TO-EOL 0 INF-X-OFFSET INF-Y-OFFSET))
- ;; At the start of each pass through the loop bind inf-screen-obj and inf-actual-obj
- ;; to the next obj in the screen and actual structures respectively.
- (DO* ((CHA-NO 0 (+ CHA-NO 1))
- (INF-ACTUAL-OBJ (TELL ACTUAL-OBJ :CHA-AT-CHA-NO CHA-NO)
- (TELL ACTUAL-OBJ :CHA-AT-CHA-NO CHA-NO))
- (INF-SCREEN-OBJ (NTH CHA-NO SCREEN-CHAS)
- (NTH CHA-NO SCREEN-CHAS)))
- ;; If there are no more inferior screen-objs or if the current state of
- ;; the clipping means that there is no room to display any more
- ;; inferiors we quit. If there are any inferior screen-objs
- ;; left in the old screen structure punt them.
- ((OR (NULL INF-ACTUAL-OBJ)
- (TELL SELF :RDP1-OUT-OF-ROOM-TO-DISPLAY-INFERIORS? INFS-NEW-X-GOT-CLIPPED?))
- (WHEN (NOT-NULL INF-SCREEN-OBJ)
- (TELL SELF :RDP1-PUNT-EXTRA-SCREEN-OBJS-FROM CHA-NO OUT-OF-SYNCH-ALREADY
- INF-X-OFFSET INF-Y-OFFSET))
- (VALUES INFS-NEW-WID INFS-NEW-HEI INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?))
-
-
-
- ;; If for any reason inf-screen-obj doesn't match inf-actual-obj
- ;; we need to patch up the screen structure. This can be
- ;; hairy, so we call in somebody else to do the job.
- (WHEN (OR (NULL INF-SCREEN-OBJ)
- (NEQ (ACTUAL-OBJ-OF-SCREEN-OBJ INF-SCREEN-OBJ) INF-ACTUAL-OBJ))
- (UNLESS OUT-OF-SYNCH-ALREADY
- (SETQ OUT-OF-SYNCH-MARK CHA-NO
- OUT-OF-SYNCH-ALREADY T)
- ;; do all the erasing of chas (but NOT boxes) in one pass while we still know where
- ;; everything is located
- (ERASE-CHAS-TO-EOL CHA-NO INF-X-OFFSET INF-Y-OFFSET))
- (SETQ INF-SCREEN-OBJ (TELL SELF :RDP1-PATCH-OUT-OF-SYNCH-LOSSAGE
- INF-ACTUAL-OBJ INF-SCREEN-OBJ
- INF-X-OFFSET INF-Y-OFFSET
- CHA-NO)))
- ;; At this point we know that inf-screen-obj and inf-actual-obj
- ;; match. If it wants to (and is a screen-box) let inf-screen-obj do :redisplay-pass-1.
- ;; if inf-screen-obj is a box, then delete it from the BOXES-TO-BE-DISPLAYED list
- (COND ((SCREEN-CHA? INF-SCREEN-OBJ)
- ;; must be a screen cha so the ROW has to check for clipping
- ;; and increment its own infs-screen-objs parameters
- (MULTIPLE-VALUE (INFS-NEW-WID INFS-NEW-HEI
- INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?
- INF-X-OFFSET
- INFS-NEW-MAX-WID)
- (SCREEN-CHA-INCREMENT-SUPERIOR-PARAMETERS INF-SCREEN-OBJ
- INFS-NEW-WID
- INFS-NEW-HEI
- INF-X-OFFSET
- INFS-NEW-MAX-WID
- INFS-NEW-MAX-HEI)))
- (T
- ;;must be a box so let the box do some work...
- ;;that is, redisplay if it wants to and then make its contribution to
- ;;all the infs-screen-objs parameters
- (WHEN (TELL INF-SCREEN-OBJ :NEEDS-REDISPLAY-PASS-1? INFS-NEW-MAX-WID
- INFS-NEW-MAX-HEI)
- (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-1 INFS-NEW-MAX-WID
- INFS-NEW-MAX-HEI)
- (UNLESS (TELL INF-SCREEN-OBJ :RDP1-UNCHANGED-WIDTH?)
- (UNLESS OUT-OF-SYNCH-ALREADY
- ;; check the box and if the redisplay has changed changed its
- ;; size, we have to flush the rest of the line
- (SETQ OUT-OF-SYNCH-MARK CHA-NO
- OUT-OF-SYNCH-ALREADY T)
- (ERASE-CHAS-TO-EOL CHA-NO INF-X-OFFSET INF-Y-OFFSET))))
- (MULTIPLE-VALUE (INFS-NEW-WID INFS-NEW-HEI
- INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?
- INF-X-OFFSET
- INFS-NEW-MAX-WID)
- (TELL INF-SCREEN-OBJ :RDP1-INCREMENT-SUPERIOR-PARAMETERS
- INFS-NEW-WID INFS-NEW-HEI
- INFS-NEW-X-GOT-CLIPPED? INFS-NEW-Y-GOT-CLIPPED?
- INF-X-OFFSET
- INFS-NEW-MAX-WID))
- ;;delete the box from the list of boxes to display
- (SETQ BOXES-TO-DISPLAY (DELQ INF-ACTUAL-OBJ BOXES-TO-DISPLAY)))))))
-
-
-
- (DEFMETHOD (SCREEN-ROW :RDP1-OUT-OF-ROOM-TO-DISPLAY-INFERIORS?) (INFS-NEW-X-GOT-CLIPPED?)
- INFS-NEW-X-GOT-CLIPPED?)
-
- (DEFUN EXTRACT-SCREEN-BOXES (LIST-OF-CHAS-OR-BOXES)
- (SUBSET #'SCREEN-BOX? LIST-OF-CHAS-OR-BOXES))
-
- (DEFMETHOD (SCREEN-ROW :RDP1-PUNT-EXTRA-SCREEN-OBJS-FROM) (NO-OF-FIRST-OBJ-TO-PUNT
- SCREEN-ALTERED? X-COORD Y-COORD)
- (LET* ((SCREEN-OBJS-TO-PUNT (TELL SELF :SCREEN-OBJS-AT-AND-AFTER NO-OF-FIRST-OBJ-TO-PUNT))
- (SCREEN-BOXES-TO-PUNT (EXTRACT-SCREEN-BOXES SCREEN-OBJS-TO-PUNT)))
- (IF SCREEN-ALTERED?
- ;; either the screen structure has been patched and the chas already erased in
- ;; which case we erase and deallocate the boxes or else we have to erase everything
- ;; which is easy since we still know where everything is since nothing has moved
- (DOLIST (SCREEN-BOX-TO-PUNT SCREEN-BOXES-TO-PUNT)
- (MULTIPLE-VALUE-BIND (BOX-X-OFFSET BOX-Y-OFFSET)
- (TELL SCREEN-BOX-TO-PUNT :OFFSETS)
- (ERASE-SCREEN-BOX SCREEN-BOX-TO-PUNT BOX-X-OFFSET BOX-Y-OFFSET)))
- (ERASE-SCREEN-CHAS SCREEN-OBJS-TO-PUNT X-COORD Y-COORD))
- (QUEUE-SCREEN-OBJS-FOR-DEALLOCATION SCREEN-BOXES-TO-PUNT)
- (TELL SELF :KILL-SCREEN-CHAS-FROM NO-OF-FIRST-OBJ-TO-PUNT)))
-
-
- ;;;this is the other main screen structure patching routine...
- ;;;it examines the state of the screen row so far and, from the
- ;;;information given, decides which of several, more specific, screen
- ;;;structure patching routines to call
-
- (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-OUT-OF-SYNCH-LOSSAGE) (INF-ACTUAL-OBJ
- INF-SCREEN-OBJ
- SCREEN-OBJ-X-OFFSET
- SCREEN-OBJ-Y-OFFSET
- CHA-NO)
- (WHEN (OBSELETE-SCREEN-BOX? INF-SCREEN-OBJ)
- ;; if the existing screen character is a screen box and the
- ;; screen box no longer belongs, erase it
- (MULTIPLE-VALUE-BIND (X-COORD Y-COORD)
- (TELL INF-SCREEN-OBJ :OFFSETS)
- (ERASE-SCREEN-BOX INF-SCREEN-OBJ X-COORD Y-COORD)))
- ;; there are two alternatives, either we want to patch up the screen structure with a
- ;; character or else we want to patch it up with a BOX. Since boxes have EQness, we
- ;; use the boxes in the row as markers. In other words, we keep on inserting chas as we
- ;; need them until we hit a box--at which point we flush all the chas between where we
- ;; are now and where the box is. This continues for each box in the row or until the end
- ;; of the line (we run out of real chas)
- (LET* ((MATCHING-SCREEN-OBJ
- (IF (CHA? INF-ACTUAL-OBJ)
- (MAKE-SCREEN-CHA INF-ACTUAL-OBJ)
- (TELL INF-ACTUAL-OBJ :ALLOCATE-SCREEN-OBJ-FOR-USE-IN
- (TELL SELF :LOWEST-SCREEN-BOX)))))
- (COND ((SCREEN-CHA? MATCHING-SCREEN-OBJ)
- (TELL SELF :RDP1-PATCH-CHA-LOSSAGE-INTERNAL MATCHING-SCREEN-OBJ CHA-NO))
- ;;must be a box that wants to be patched
- ((EQ SELF (TELL MATCHING-SCREEN-OBJ :SUPERIOR))
- ;;the screen box is already in the current row
- (TELL SELF :RDP1-PATCH-BOX-IN-ROW-LOSSAGE-INTERNAL MATCHING-SCREEN-OBJ CHA-NO))
- ((NOT-NULL (TELL MATCHING-SCREEN-OBJ :SUPERIOR))
- ;; the screen box exists but is not in the present row
- (TELL SELF :RDP1-PATCH-BOX-NOT-IN-ROW-LOSSAGE-INTERNAL
- MATCHING-SCREEN-OBJ CHA-NO SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET))
- (T
- ;;the screen box has never been displayed (it was just made)
- (TELL SELF :RDP1-PATCH-NEW-BOX-LOSSAGE-INTERNAL
- MATCHING-SCREEN-OBJ CHA-NO SCREEN-OBJ-X-OFFSET SCREEN-OBJ-Y-OFFSET)))
- MATCHING-SCREEN-OBJ))
-
-
-
- (DEFUN-METHOD GATHER-SCREEN-CHAS SCREEN-ROW (START-NO END-NO)
- (FIRSTN (- END-NO START-NO)
- (NTHCDR START-NO SCREEN-CHAS)))
-
- (DEFUN-METHOD GATHER-SCREEN-BOXES SCREEN-ROW (START-NO END-NO)
- (SUBSET #'SCREEN-BOX? (GATHER-SCREEN-CHAS START-NO END-NO)))
-
- (DEFUN-METHOD OBSELETE-SCREEN-BOX? SCREEN-ROW (TEST-SCREEN-CHA)
- (WHEN (SCREEN-BOX? TEST-SCREEN-CHA)
- (NOT (MEMQ (TELL TEST-SCREEN-CHA :ACTUAL-OBJ) (TELL ACTUAL-OBJ :BOXES-IN-ROW)))))
-
- ;;;specific screen structure patching methods...
-
- (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-CHA-LOSSAGE-INTERNAL) (MATCHING-SCREEN-OBJ POSITION)
- (TELL SELF :INSERT-SCREEN-CHA-AT-CHA-NO MATCHING-SCREEN-OBJ POSITION))
-
- (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-BOX-IN-ROW-LOSSAGE-INTERNAL) (MATCHING-SCREEN-BOX POSITION)
- (LET ((BOX-LOCATION (FIND-POSITION-IN-LIST MATCHING-SCREEN-BOX SCREEN-CHAS)))
- ;; flush all the intervening chas
- (TELL SELF :DELETE-SCREEN-CHAS-FROM-TO POSITION BOX-LOCATION)))
-
- (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-BOX-NOT-IN-ROW-LOSSAGE-INTERNAL) (MATCHING-SCREEN-BOX
- POSITION
- SCREEN-CHA-X-OFFSET
- SCREEN-CHA-Y-OFFSET)
- ;; First we need to get matching-screen-obj-and-next-screen-objs. Then
- ;; we erase these screen objs, kill them from the superior they are in,
- ;; and insert them in this superior.
- (LET ((MATCHING-SCREEN-BOX-AND-NEXT-SCREEN-CHAS
- (TELL MATCHING-SCREEN-BOX :SELF-AND-NEXT-SCREEN-CHAS))
- (MATCHING-SCREEN-BOX-SCREEN-ROW
- (TELL MATCHING-SCREEN-BOX :SCREEN-ROW)))
- (WITH-ORIGIN-AT ((- (SCREEN-OBJ-X-OFFSET MATCHING-SCREEN-BOX-SCREEN-ROW) X-OFFSET)
- (- (SCREEN-OBJ-Y-OFFSET MATCHING-SCREEN-BOX-SCREEN-ROW) Y-OFFSET))
- (MULTIPLE-VALUE-BIND (X-COORD Y-COORD)
- (TELL MATCHING-SCREEN-BOX :OFFSETS)
- (ERASE-SCREEN-CHAS MATCHING-SCREEN-BOX-AND-NEXT-SCREEN-CHAS X-COORD Y-COORD)))
- (TELL MATCHING-SCREEN-BOX-SCREEN-ROW :KILL-SCREEN-CHA MATCHING-SCREEN-BOX)
- (TELL SELF :INSERT-SCREEN-CHAS-AT-CHA-NO MATCHING-SCREEN-BOX-AND-NEXT-SCREEN-CHAS
- POSITION)
- (DOLIST (SCR-BOX (EXTRACT-SCREEN-BOXES MATCHING-SCREEN-BOX-AND-NEXT-SCREEN-CHAS))
- (SET-SCREEN-OBJ-OFFSETS SCR-BOX SCREEN-CHA-X-OFFSET SCREEN-CHA-Y-OFFSET))))
-
- (DEFMETHOD (SCREEN-ROW :RDP1-PATCH-NEW-BOX-LOSSAGE-INTERNAL) (MATCHING-SCREEN-BOX
- POSITION
- SCREEN-CHA-X-OFFSET
- SCREEN-CHA-Y-OFFSET)
- ;; just insert the new box in the right place and we're done
- (TELL SELF :INSERT-SCREEN-CHA-AT-CHA-NO MATCHING-SCREEN-BOX POSITION)
- (SET-SCREEN-OBJ-OFFSETS MATCHING-SCREEN-BOX SCREEN-CHA-X-OFFSET SCREEN-CHA-Y-OFFSET))
-
-
-
- (DEFMETHOD (SCREEN-BOX :RDP1-UNCHANGED-WIDTH?) ()
- (ZEROP (- NEW-WID WID)))
-
- (DEFUN SCREEN-CHA-INCREMENT-SUPERIOR-PARAMETERS (SCREEN-CHA
- INFS-NEW-WID
- INFS-NEW-HEI
- INF-X-OFFSET
- INFS-NEW-MAX-WID
- INFS-NEW-MAX-HEI)
- (LET* ((FONT (FONT-NO SCREEN-CHA))
- (CODE (CHA-CODE SCREEN-CHA))
- (WID (CHA-WID FONT CODE))
- (HEI (CHA-HEI FONT)))
- (VALUES (+ INFS-NEW-WID WID)
- (MAX INFS-NEW-HEI HEI)
- (> WID INFS-NEW-MAX-WID)
- (> HEI INFS-NEW-MAX-HEI)
- (+ INF-X-OFFSET WID)
- (- INFS-NEW-MAX-WID WID))))
-
- ;;;only boxes and rows should be getting this message (NOT chas)
- (DEFMETHOD (SCREEN-BOX :RDP1-INCREMENT-SUPERIOR-PARAMETERS) (INFS-NEW-WID
- INFS-NEW-HEI
- INFS-NEW-X-GOT-CLIPPED?
- INFS-NEW-Y-GOT-CLIPPED?
- INF-X-OFFSET
- INFS-NEW-MAX-WID)
- (VALUES (+ INFS-NEW-WID NEW-WID)
- (MAX INFS-NEW-HEI NEW-HEI)
- (OR INFS-NEW-X-GOT-CLIPPED? NEW-X-GOT-CLIPPED?)
- (OR INFS-NEW-Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?)
- (+ INF-X-OFFSET WID)
- (- INFS-NEW-MAX-WID NEW-WID)))
-
-
-
- (COMMENT
- ;; Until we introduce chas that are allowed to change their font,
- ;; all the redisplay-pass-1 method for screen chas has to do is compute
- ;; the new size and new got clipped of the screen cha. There are two
- ;; cases for this:
- ;; There is enough room to fit the entire screen cha:
- ;; The screen cha takes up all the room it needs and
- ;; doesn't get clipped.
- ;; There isn't enough room to fit the entire screen cha:
- ;; The screen cha takes up as much of its ideal size
- ;; as it can get (this prevents the next screen cha
- ;; from trying to display itself at this screen cha's
- ;; position), and does get clipped.
-
- (DEFMETHOD (SCREEN-CHA :REDISPLAY-PASS-1) (MAX-WID MAX-HEI)
- (LET* ((CHA-CODE (TELL ACTUAL-OBJ :CHA-CODE))
- (FONT-NO (TELL ACTUAL-OBJ :FONT-NO))
- (IDEAL-WID (CHA-WID FONT-NO CHA-CODE))
- (IDEAL-HEI (CHA-HEI FONT-NO)))
- (VALUES (SETQ NEW-WID (MIN IDEAL-WID MAX-WID))
- (SETQ NEW-HEI (MIN IDEAL-HEI MAX-HEI))
- (SETQ NEW-X-GOT-CLIPPED? (> IDEAL-WID MAX-WID))
- (SETQ NEW-Y-GOT-CLIPPED? (> IDEAL-HEI MAX-HEI)))))
- )
-
-
-
- (DEFMETHOD (SCREEN-ROW :REDISPLAY-PASS-1) (MAX-WID MAX-HEI)
- (MULTIPLE-VALUE (NEW-WID NEW-HEI NEW-X-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?)
- (TELL SELF :REDISPLAY-INFERIORS-PASS-1 MAX-WID MAX-HEI))
- (MAXIMIZE NEW-HEI (CHA-HEI *CURRENT-FONT-NO*)))
-
- (DEFMETHOD (SCREEN-BOX :REDISPLAY-PASS-1) (MAX-WID MAX-HEI)
- (LET ((NEW-BOX-TYPE (TELL ACTUAL-OBJ :TYPE)))
- (MULTIPLE-VALUE-BIND (L-BORDER-WID T-BORDER-WID R-BORDER-WID B-BORDER-WID)
- (BOX-BORDERS-FN ':BORDER-WIDS NEW-BOX-TYPE SELF)
- (MULTIPLE-VALUE-BIND (MIN-WID MIN-HEI)
- (BOX-BORDERS-FN ':MINIMUM-SIZE NEW-BOX-TYPE SELF)
- (MULTIPLE-VALUE-BIND (FIXED-WID FIXED-HEI)
- (TELL SELF :FIXED-SIZE)
- (LET (;; If the screen-box has a fixed size, then the fixed
- ;; size effectively sets both upper and lower limits
- ;; on the size of the box.
- (REAL-MAX-WID (IF (NULL FIXED-WID)
- MAX-WID
- (MIN MAX-WID (+ FIXED-WID L-BORDER-WID R-BORDER-WID))))
- (REAL-MAX-HEI (IF (NULL FIXED-HEI)
- MAX-HEI
- (MIN MAX-HEI (+ FIXED-HEI T-BORDER-WID B-BORDER-WID))))
- (REAL-MIN-WID (IF (NULL FIXED-WID)
- MIN-WID
- (MAX MIN-WID (+ FIXED-WID L-BORDER-WID R-BORDER-WID))))
- (REAL-MIN-HEI (IF (NULL FIXED-HEI)
- MIN-HEI
- (MAX MIN-HEI (+ FIXED-HEI T-BORDER-WID B-BORDER-WID)))))
- (SETQ NEW-WID (+ L-BORDER-WID R-BORDER-WID)
- NEW-HEI (+ T-BORDER-WID B-BORDER-WID))
- ;; Now that we know how much room the borders are going to
- ;; take up, and we know the real max size of the screen-box,
- ;; we can go off and figure out how much space the screen-rows
- ;; are going to take up.
- (MULTIPLE-VALUE-BIND (ROWS-NEW-WID ROWS-NEW-HEI
- ROWS-NEW-X-GOT-CLIPPED? ROWS-NEW-Y-GOT-CLIPPED?)
- (TELL SELF :REDISPLAY-INFERIORS-PASS-1 (- REAL-MAX-WID NEW-WID)
- (- REAL-MAX-HEI NEW-HEI)
- L-BORDER-WID
- T-BORDER-WID
- SCROLL-TO-ACTUAL-ROW)
- (INCF NEW-WID ROWS-NEW-WID)
- (INCF NEW-HEI ROWS-NEW-HEI)
- ;; Make sure that we are at least as big as our minimum size.
- (SETQ NEW-WID (MIN (MAX NEW-WID REAL-MIN-WID) REAL-MAX-WID)
- NEW-HEI (MIN (MAX NEW-HEI REAL-MIN-HEI) REAL-MAX-HEI)
- NEW-X-GOT-CLIPPED? (AND (OR (< REAL-MAX-WID REAL-MIN-WID)
- ROWS-NEW-X-GOT-CLIPPED?)
- (OR (NOT FIXED-WID)
- (> FIXED-WID MAX-WID)))
- NEW-Y-GOT-CLIPPED? (AND (OR (< REAL-MAX-HEI REAL-MIN-HEI)
- ROWS-NEW-Y-GOT-CLIPPED?)
- (OR (NOT FIXED-HEI)
- (> FIXED-HEI MAX-HEI))))
- ;; What hair!!! If we are changing size, then we need to
- ;; erase the part of our borders that need are going to
- ;; need erasing.
- (COND ((NOT-NULL FORCE-REDISPLAY-INFS?)
- ;; If we are being asked to completely redraw our inferiors,
- ;; then we have to blank that area of the screen. We don't
- ;; use erase-screen-obj to do this because we still want to
- ;; "take up" that space.
- (DRAW-RECTANGLE TV:ALU-ANDCA WID HEI 0 0))
- ((NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*))
- ((NEQ BOX-TYPE NEW-BOX-TYPE)
- (BOX-BORDERS-FN
- ':CHANGE-SIZE-PASS-1 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0))
- ((NOT (STRING-EQUAL NAME (TELL-CHECK-NIL (TELL ACTUAL-OBJ :NAME-ROW)
- :TEXT-STRING)))
- (BOX-BORDERS-FN
- ':CHANGE-NAME-PASS-1 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0))
- ((AND (OR ( WID NEW-WID) ( HEI NEW-HEI))
- (NEQ Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?))
- ;; what this REALLY wants to check is if the tab got clipped vertically
- (BOX-BORDERS-FN
- ':CHANGE-NAME-PASS-1 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0))
- ((OR ( WID NEW-WID) ( HEI NEW-HEI))
- (BOX-BORDERS-FN
- ':CHANGE-SIZE-PASS-1 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0)))
- (TELL SELF :ADJUST-INFERIOR-OFFSETS-AFTER-NAMING
- L-BORDER-WID (NULL (TELL ACTUAL-OBJ :NAME-ROW)))
- (VALUES NEW-WID NEW-HEI NEW-X-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?))))))))
-
- (DEFMETHOD (SCREEN-BOX :ADJUST-INFERIOR-OFFSETS-AFTER-NAMING) (&OPTIONAL(FIRST-INF-X-OFFSET 0)
- (FORCE-P NIL))
- ;; we can't just blit the rows over during pass 1 because we are being clipped to our
- ;; old wid and NOT how big we WANT to be
- (WHEN (#+SYMBOLICS LISTP #-SYMBOLICS CONSP SCREEN-ROWS)
- (LET ((NAME-ROW (TELL ACTUAL-OBJ :NAME-ROW))
- (DELTA-X (- FIRST-INF-X-OFFSET (OR (AND SCREEN-ROWS
- (SCREEN-OBJ-X-OFFSET (CAR SCREEN-ROWS)))
- 0))))
- (COND ((AND (OR NAME-ROW FORCE-P)(EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK))
- (MULTIPLE-VALUE-BIND (L-OLD-WID T-OLD-WID R-OLD-WID B-OLD-WID)
- (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF ':OLD)
- (DRAW-RECTANGLE TV:ALU-ANDCA (- WID L-OLD-WID R-OLD-WID)
- (- HEI T-OLD-WID B-OLD-WID) L-OLD-WID T-OLD-WID)))
- ((AND (OR NAME-ROW FORCE-P) (NOT (ZEROP DELTA-X)))
- (SETQ INF-HOR-SHIFT DELTA-X))))))
-
- (DEFMETHOD (GRAPHICS-SCREEN-BOX :ADJUST-INFERIOR-OFFSETS-AFTER-NAMING)(&OPTIONAL
- (FIRST-INF-X-OFFSET 0)
- (FORCE-P NIL))
- ;; we can't just blit the graphics sheet over during pass 1 because we are being clipped
- ;; to our old wid and NOT how big we want to be
- (LET ((NAME-ROW (TELL ACTUAL-OBJ :NAME-ROW))
- (DELTA-X (- FIRST-INF-X-OFFSET (OR (AND (NOT-NULL (TELL SELF :SCREEN-SHEET))
- (GRAPHICS-SCREEN-SHEET-X-OFFSET
- (TELL SELF :SCREEN-SHEET)))
- 0))))
- (COND ((EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK)
- (MULTIPLE-VALUE-BIND (L-OLD-WID T-OLD-WID R-OLD-WID B-OLD-WID)
- (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF ':OLD)
- (DRAW-RECTANGLE TV:ALU-ANDCA (- WID L-OLD-WID R-OLD-WID)
- (- HEI T-OLD-WID B-OLD-WID) L-OLD-WID T-OLD-WID)))
- ((AND (OR NAME-ROW FORCE-P) (NOT (ZEROP DELTA-X)))
- (SETQ INF-HOR-SHIFT DELTA-X)))))
-
- (DEFMETHOD (SCREEN-BOX :SET-SCROLL-TO-ACTUAL-ROW) (NEW-VALUE)
- (UNLESS (EQ NEW-VALUE SCROLL-TO-ACTUAL-ROW)
- (WHEN (MEMQ NEW-VALUE (TELL-CHECK-NIL ACTUAL-OBJ :ROWS))
- (SETQ SCROLL-TO-ACTUAL-ROW NEW-VALUE)
- (TELL SELF :SET-FORCE-REDISPLAY-INFS? T))))
-
- (DEFMETHOD (SCREEN-BOX :SCROLL-DN-ONE-SCREEN-BOX) ()
- (LET ((LAST-SCREEN-ROW (CAR (LAST SCREEN-ROWS))))
- (UNLESS (NULL LAST-SCREEN-ROW)
- (TELL SELF :SET-SCROLL-TO-ACTUAL-ROW (SCREEN-OBJ-ACTUAL-OBJ LAST-SCREEN-ROW)))))
-
- (DEFMETHOD (SCREEN-BOX :SCROLL-UP-ONE-SCREEN-BOX) ()
- (UNLESS (OR (NULL ACTUAL-OBJ) (NULL SCREEN-ROWS))
- (ENSURE-ROW-IS-DISPLAYED (SCREEN-OBJ-ACTUAL-OBJ (CAR SCREEN-ROWS)) SELF -1 T)))
-
- (DEFVAR *SHRUNK-BOX-WID* 20.)
- (DEFVAR *SHRUNK-BOX-HEI* 10.)
-
-
-
- (DEFUN-METHOD DRAW-PORT-BOX-ELLIPSIS? SCREEN-BOX ()
- (AND (PORT-BOX? ACTUAL-OBJ)
- (BOX-ELLIPSIS-STYia? SCREEN-ROWS)))
-
- (DEFUN-METHOD DRAW-PORT-BOX-ELLIPSIS SCREEN-BOX (X Y)
- (FUNCALL (GET SCREEN-ROWS 'DRAW-SELF) X Y))
-
- (DEFMETHOD (SCREEN-BOX :REDISPLAY-INFERIORS-PASS-2) ()
- (IF (DRAW-PORT-BOX-ELLIPSIS?)
- (MULTIPLE-VALUE-BIND (IL IT)
- (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
- (DRAW-PORT-BOX-ELLIPSIS IL IT))
- (DO* ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
- FORCE-REDISPLAY-INFS?))
- (INF-SCREEN-OBJS (TELL SELF :INFERIORS) (CDR INF-SCREEN-OBJS))
- (INF-SCREEN-OBJ (CAR INF-SCREEN-OBJS) (CAR INF-SCREEN-OBJS)))
- ((NULL INF-SCREEN-OBJS))
- (WHEN (TELL INF-SCREEN-OBJ :NEEDS-REDISPLAY-PASS-2?)
- (MULTIPLE-VALUE-BIND (NEXT-SCREEN-OBJ-DELTA-X NEXT-SCREEN-OBJ-DELTA-Y)
- (TELL INF-SCREEN-OBJ :RDINF-P2-NEXT-SCREEN-OBJ-DELTA-OFFSETS)
- (COND ((OR (PLUSP NEXT-SCREEN-OBJ-DELTA-X)
- (PLUSP NEXT-SCREEN-OBJ-DELTA-Y))
- (MOVE-SCREEN-OBJS (CDR INF-SCREEN-OBJS) NEXT-SCREEN-OBJ-DELTA-X
- NEXT-SCREEN-OBJ-DELTA-Y)
- (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-2))
- ((OR (MINUSP NEXT-SCREEN-OBJ-DELTA-X)
- (MINUSP NEXT-SCREEN-OBJ-DELTA-Y))
- (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-2)
- (MOVE-SCREEN-OBJS (CDR INF-SCREEN-OBJS) NEXT-SCREEN-OBJ-DELTA-X
- NEXT-SCREEN-OBJ-DELTA-Y))
- (T
- (TELL INF-SCREEN-OBJ :REDISPLAY-PASS-2))))))))
-
- (DEFMETHOD (SCREEN-ROW :RDINF-P2-NEXT-SCREEN-OBJ-DELTA-OFFSETS) ()
- (VALUES 0 (- NEW-HEI HEI)))
-
- ;;;this can be optimized (later...)
- (DEFMETHOD (SCREEN-ROW :REDISPLAY-INFERIORS-PASS-2) ()
- (LET* ((*COMPLETE-REDISPLAY-IN-PROGRESS?*
- (OR *COMPLETE-REDISPLAY-IN-PROGRESS?* FORCE-REDISPLAY-INFS?))
- (INF-X-OFFSET 0)
- (INF-Y-OFFSET 0)
- (START-POSITION (IF (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
- (NULL OUT-OF-SYNCH-MARK))
- 0
- OUT-OF-SYNCH-MARK))
- (BOXES-TO-DISPLAY (EXTRACT-SCREEN-BOXES (NTHCDR START-POSITION SCREEN-CHAS))))
- (DO* ((CHA-NO 0 (+ CHA-NO 1))
- (INF-SCREEN-OBJS (NTHCDR CHA-NO SCREEN-CHAS) (NTHCDR CHA-NO SCREEN-CHAS))
- (INF-SCREEN-OBJ (CAR INF-SCREEN-OBJS) (CAR INF-SCREEN-OBJS)))
- ((NULL INF-SCREEN-OBJS))
- (COND ((< CHA-NO START-POSITION)) ;don't need to do any drawing yet
- ((AND (SCREEN-CHA? INF-SCREEN-OBJ)
- ( (RDINF-P2-NEXT-SCREEN-BOX-DELTA-X-OFFSET BOXES-TO-DISPLAY
- INF-SCREEN-OBJ
- INF-X-OFFSET)
- 0))
- ;; we want to draw a cha AND there is enough room to do it without having to move
- ;; any boxes
- (DRAW-CHA TV:ALU-IOR (FONT-NO INF-SCREEN-OBJ) (CHA-CODE INF-SCREEN-OBJ)
- INF-X-OFFSET INF-Y-OFFSET))
- ((SCREEN-CHA? INF-SCREEN-OBJ)
- ;; we have to move some boxes out of the way before we can draw the next cha
- (MOVE-SCREEN-BOXES BOXES-TO-DISPLAY
- (RDINF-P2-NEXT-SCREEN-BOX-DELTA-X-OFFSET BOXES-TO-DISPLAY
- INF-SCREEN-OBJ
- INF-X-OFFSET)
- 0)
- (DRAW-CHA TV:ALU-IOR (FONT-NO INF-SCREEN-OBJ) (CHA-CODE INF-SCREEN-OBJ)
- INF-X-OFFSET INF-Y-OFFSET))
- ;; must be a box that wants to be displayed
- (T (IF (EQ INF-SCREEN-OBJ (CAR BOXES-TO-DISPLAY))
- (RDINF-P2-PATCH-BOX-LOSSAGE BOXES-TO-DISPLAY INF-X-OFFSET)
- (FERROR "The current screen object ~S does not match with the first screen
- box ~S" INF-SCREEN-OBJ (CAR BOXES-TO-DISPLAY)))
- (SETQ BOXES-TO-DISPLAY (DELQ INF-SCREEN-OBJ BOXES-TO-DISPLAY))))
- (SETQ INF-X-OFFSET (RDINF-P2-INCREMENT-OFFSET INF-SCREEN-OBJ INF-X-OFFSET)))))
-
- (DEFUN RDINF-P2-PATCH-BOX-LOSSAGE (BOXES-TO-PATCH CURRENT-X-OFFSET)
- (LET* ((BOX-TO-PATCH (CAR BOXES-TO-PATCH))
- (DELTA-X (- CURRENT-X-OFFSET (SCREEN-OBJ-X-OFFSET BOX-TO-PATCH)))
- (BOXES-LEFT (CDR BOXES-TO-PATCH))
- (NEXT-BOX-OFFSET (RDINF-P2-NEXT-SCREEN-BOX-DELTA-X-OFFSET BOXES-LEFT
- BOX-TO-PATCH
- CURRENT-X-OFFSET)))
- (UNLESS (ZEROP DELTA-X)
- ;; move the box to the right place
- (MOVE-SCREEN-BOXES BOXES-TO-PATCH DELTA-X 0))
- (UNLESS ( NEXT-BOX-OFFSET 0)
- ;; if the other boxes are in the way move them out of the way
- (MOVE-SCREEN-BOXES BOXES-LEFT NEXT-BOX-OFFSET 0))
- (WHEN (TELL BOX-TO-PATCH :NEEDS-REDISPLAY-PASS-2?)
- ;; if the box wants to, let it do a redisplay pass 2
- (TELL BOX-TO-PATCH :REDISPLAY-PASS-2))))
-
- (DEFUN RDINF-P2-NEXT-SCREEN-BOX-DELTA-X-OFFSET (SCREEN-BOXES-LEFT
- CURRENT-SCREEN-OBJECT CURRENT-X-OFFSET)
- (IF (NULL SCREEN-BOXES-LEFT)
- 0
- (- (RDINF-P2-NEXT-SCREEN-OBJ-X-OFFSET CURRENT-SCREEN-OBJECT CURRENT-X-OFFSET)
- (SCREEN-OBJ-X-OFFSET (CAR SCREEN-BOXES-LEFT)))))
-
- (DEFUN RDINF-P2-NEXT-SCREEN-OBJ-X-OFFSET (CURRENT-SCREEN-OBJ CURRENT-X-OFFSET)
- (+ CURRENT-X-OFFSET (SCREEN-OBJECT-NEW-WIDTH CURRENT-SCREEN-OBJ)))
-
- (DEFUN RDINF-P2-INCREMENT-OFFSET (SCREEN-CHA-OR-BOX OLD-X-OFFSET)
- (+ OLD-X-OFFSET (SCREEN-OBJECT-WIDTH SCREEN-CHA-OR-BOX)))
-
- (DEFMETHOD (SCREEN-ROW :REDISPLAY-PASS-2) ()
- (TELL SELF :REDISPLAY-INFERIORS-PASS-2)
- (TELL SELF :GOT-REDISPLAYED))
-
- (DEFUN-METHOD BRAND-NEW? SCREEN-OBJ () (= TICK -1))
-
- (DEFMETHOD (SCREEN-BOX :REDISPLAY-PASS-2) ()
- (LET ((NEW-BOX-TYPE (TELL ACTUAL-OBJ :TYPE)))
- (COND ((EQ (TELL SELF :DISPLAY-STYLE) ':SHRUNK)
- (TELL SELF :NAME-AND-INPUTS-ONLY))
- (T (UNLESS (OR (ZEROP INF-HOR-SHIFT)
- (NOT (#+SYMBOLICS LISTP #-SYMBOLICS CONSP SCREEN-ROWS)))
- ;; we have to move the inferiors here in rdp2 because the clipping
- ;; in rdp1 is too restrictive
- (MOVE-INFERIOR-SCREEN-OBJS SCREEN-ROWS INF-HOR-SHIFT 0))
- (TELL SELF :REDISPLAY-INFERIORS-PASS-2)))
- ;; Now deal with the Borders, If they are completely
- ;; erased, redraw them from scratch. If we are changing
- ;; size, redraw the parts that pass-1 erased.
- (COND ((NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)
- (BOX-BORDERS-FN ':DRAW BOX-TYPE SELF NEW-WID NEW-HEI 0 0))
- ((NEQ NEW-BOX-TYPE BOX-TYPE)
- (BOX-BORDERS-FN
- ':CHANGE-SIZE-PASS-2 NEW-BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0)
- (SETQ BOX-TYPE NEW-BOX-TYPE))
- ((NOT (STRING-EQUAL NAME (TELL-CHECK-NIL (TELL ACTUAL-OBJ :NAME-ROW)
- :TEXT-STRING)))
- (BOX-BORDERS-FN
- ':CHANGE-NAME-PASS-2 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0)
- (SETQ NAME (TELL-CHECK-NIL (TELL ACTUAL-OBJ :NAME-ROW) :TEXT-STRING)))
- ((AND (OR ( WID NEW-WID) ( HEI NEW-HEI))
- (OR (BRAND-NEW?) (NEQ Y-GOT-CLIPPED? NEW-Y-GOT-CLIPPED?)))
- ;; what this REALLY wants to check is if the tab got clipped vertically
- (BOX-BORDERS-FN
- ':CHANGE-NAME-PASS-2 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0))
- ((OR ( WID NEW-WID) ( HEI NEW-HEI))
- (BOX-BORDERS-FN
- ':CHANGE-SIZE-PASS-2 BOX-TYPE SELF WID HEI NEW-WID NEW-HEI 0 0)))
- ;; Make a note of the fact that this screen box has
- ;; been redisplayed (pass-1 and pass-2 complete).
- (TELL SELF :GOT-REDISPLAYED)))
-
- (DEFMETHOD (SCREEN-BOX :GRAY-BODY) ()
- (MULTIPLE-VALUE-BIND (IL IT IB IR)
- (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
- (LET ((INSIDE-WID (- NEW-WID (+ IR IL)))
- (INSIDE-HEI (- NEW-HEI (+ IB IT))))
- (WITH-DRAWING-INSIDE-REGION (IL IT INSIDE-WID INSIDE-HEI)
- (BITBLT-TO-SCREEN
- TV:ALU-IOR INSIDE-WID INSIDE-HEI *GRAY1* 0 0 0 0)))))
-
-
-
- ;;;redisplay for graphics boxes
-
- (DEFMETHOD (GRAPHICS-SCREEN-BOX :REDISPLAY-INFERIORS-PASS-1) (INFS-NEW-MAX-WID
- INFS-NEW-MAX-HEI
- &OPTIONAL
- (FIRST-INF-X-OFFSET 0)
- (FIRST-INF-Y-OFFSET 0)
- IGNORE)
- (LET* ((GRAPHICS-SHEET (TELL ACTUAL-OBJ :GRAPHICS-SHEET))
- (DESIRED-WID (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET))
- (DESIRED-HEI (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)))
- ;; first make-sure that there is a screen object for the graphics sheet
-
- (WHEN (NULL (TELL SELF :SCREEN-SHEET))
- (TELL SELF :SET-SCREEN-SHEET (ALLOCATE-SCREEN-SHEET-FOR-USE-IN GRAPHICS-SHEET SELF))
- ;; now adjust the offsets of the graphics-screen-sheet
- (LET ((SCREEN-SHEET (TELL SELF :SCREEN-SHEET)))
- (UNLESS (= FIRST-INF-X-OFFSET (GRAPHICS-SCREEN-SHEET-X-OFFSET SCREEN-SHEET))
- (SET-GRAPHICS-SCREEN-SHEET-X-OFFSET SCREEN-SHEET FIRST-INF-X-OFFSET))
- (UNLESS (= FIRST-INF-Y-OFFSET (GRAPHICS-SCREEN-SHEET-Y-OFFSET SCREEN-SHEET))
- (SET-GRAPHICS-SCREEN-SHEET-Y-OFFSET SCREEN-SHEET FIRST-INF-Y-OFFSET))))
- ;; error check, remove this SOON !!!!!!!
- (IF (NOT (GRAPHICS-SCREEN-SHEET? SCREEN-ROWS))
- (FERROR "The object ~S, inside of ~S is not a GRAPHICS-SHEET. " SCREEN-ROWS SELF)
-
-
- (VALUES (MIN DESIRED-WID INFS-NEW-MAX-WID) ;width of the innards
- ;; either there is enough room for the entire bit-array to
- ;; be displayed or else we return whatever room we are given
- (MIN DESIRED-HEI INFS-NEW-MAX-HEI) ;height of the innards
- ;; same argument as above
- (> DESIRED-WID INFS-NEW-MAX-WID) ;x-got-clipped?
- (> DESIRED-HEI INFS-NEW-MAX-HEI))))) ;y-got-clipped?
-
- (DEFMETHOD (GRAPHICS-SCREEN-BOX :REDISPLAY-INFERIORS-PASS-2) ()
- (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?*
- (OR *COMPLETE-REDISPLAY-IN-PROGRESS?* FORCE-REDISPLAY-INFS?))
- (GRAPHICS-SHEET (GRAPHICS-SCREEN-SHEET-ACTUAL-OBJ (TELL SELF :SCREEN-SHEET))))
- (MULTIPLE-VALUE-BIND (X Y)
- (GRAPHICS-SCREEN-SHEET-OFFSETS (TELL SELF :SCREEN-SHEET))
- (MULTIPLE-VALUE-BIND (WIDTH HEIGHT)
- (TELL ACTUAL-OBJ :GRAPHICS-SHEET-SIZE)
- (BITBLT-TO-SCREEN TV:ALU-SETA WIDTH HEIGHT (GRAPHICS-SHEET-BIT-ARRAY GRAPHICS-SHEET)
- 0 0 X Y)))))
-
-
-
- (DEFUN REDISPLAY-WINDOW (&OPTIONAL (WINDOW *BOXER-PANE*))
- (REDISPLAYING-WINDOW (WINDOW)
- (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* (OR *COMPLETE-REDISPLAY-IN-PROGRESS?*
- (ASSQ ':CLEAR-SCREEN *REDISPLAY-CLUES*))))
- (COND ((NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)
- (TELL WINDOW #-SYMBOLICS :CLEAR-SCREEN #+SYMBOLICS :CLEAR-WINDOW)))
- (REDISPLAY-PASS-1)
- (REDISPLAY-PASS-2))))
-
- (DEFUN REDISPLAY ()
- (DOLIST (REDISPLAYABLE-WINDOW *REDISPLAYABLE-WINDOWS*)
- (REDISPLAY-WINDOW REDISPLAYABLE-WINDOW))
- (DOLIST (REGION REGION-LIST)
- (TELL-CHECK-NIL REGION :UPDATE-REDISPLAY-ALL-ROWS))
- (SETQ *REDISPLAY-CLUES* NIL)
- (REDISPLAY-CURSOR))
-
- (DEFUN FORCE-REDISPLAY ()
- (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* T))
- (REDISPLAY)))
-
- (DEFUN FORCE-REDISPLAY-WINDOW (&OPTIONAL (WINDOW *BOXER-PANE*))
- (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* T))
- (REDISPLAY-WINDOW WINDOW)))
-
- (DEFUN REDISPLAY-CURSOR (&OPTIONAL (CURSOR *POINT*))
- (WITH-FONT-MAP-BOUND (*BOXER-PANE*)
- (AND (BP? CURSOR)
- (LET ((POSITIONS (BP-POSITIONS CURSOR))
- (CHA (BP-CHA *POINT*)))
- (WHEN POSITIONS
- (TELL *BOXER-PANE* :SET-CURSORPOS (CAR POSITIONS) (CDR POSITIONS))
- (TELL *POINT-BLINKER* :SET-SIZE 3 (get-cursor-height cha)))))))
-
- (defun get-cursor-height (cha)
- (COND ((NULL CHA) 12)
- ((CHA? CHA) (CHA-HEI (FONT-NO CHA)))
- ((and (box? cha) (null (tell cha :displayed-screen-objs)))
- 17)
- ((EQ ':SHRUNK
- (TELL (BP-SCREEN-BOX *POINT*)
- :DISPLAY-STYLE))
- (- (SCREEN-OBJ-HEI (BP-SCREEN-BOX *POINT*))
- 17))
- ((name-row? (tell cha :name-row))
- (multiple-value-bind (ignore hei)
- (screen-box-borders-fn ':tab-size (car (tell cha :displayed-screen-objs)))
- (+ hei 7)))
- (T
- (let ((sb (INF-CURRENT-SCREEN-BOX CHA)))
- (if (null sb) 17 (SCREEN-OBJ-HEI sb))))))
-
-
-
- (DEFUN REDISPLAY-PASS-1 ()
- (MULTIPLE-VALUE-BIND (MAX-WID MAX-HEI)
- (OUTERMOST-SCREEN-BOX-SIZE *REDISPLAY-WINDOW*)
- (COND ((NULL *OUTERMOST-SCREEN-BOX*))
- ((TELL *OUTERMOST-SCREEN-BOX* :NEEDS-REDISPLAY-PASS-1? MAX-WID MAX-HEI)
- (TELL *OUTERMOST-SCREEN-BOX* :REDISPLAY-PASS-1 MAX-WID MAX-HEI)))))
-
- (DEFUN REDISPLAY-PASS-2 ()
- (WHEN (TELL *OUTERMOST-SCREEN-BOX* :NEEDS-REDISPLAY-PASS-2?)
- (TELL *OUTERMOST-SCREEN-BOX* :REDISPLAY-PASS-2)))
-
- (DEFUN REDISPLAY-SCREEN-BOX (SCREEN-BOX)
- (REDISPLAYING-BOX SCREEN-BOX
- (COND ((NOT-NULL *COMPLETE-REDISPLAY-IN-PROGRESS?*)
- (ERASE-SCREEN-OBJ SCREEN-BOX)))
- (MULTIPLE-VALUE-BIND (MAX-WID MAX-HEI)
- (SCREEN-OBJ-SIZE SCREEN-BOX)
- (COND ((NULL SCREEN-BOX))
- ((TELL SCREEN-BOX :NEEDS-REDISPLAY-PASS-1? MAX-WID MAX-HEI)
- (TELL SCREEN-BOX :REDISPLAY-PASS-1 MAX-WID MAX-HEI))))
- (WHEN (TELL SCREEN-BOX :NEEDS-REDISPLAY-PASS-2?)
- (TELL SCREEN-BOX :REDISPLAY-PASS-2))))
-
- (DEFUN REDISPLAY-BOX (BOX) ;this is the right thing to call on fixed size
- (DOLIST (SCREEN-BOX (TELL BOX :DISPLAYED-SCREEN-OBJS)) ;actual boxes
- (REDISPLAY-SCREEN-BOX SCREEN-BOX)))
-